;;;;  $Id: main.sld -1   $
;;;;
;;;;  Copyright (c) Dorai Sitaram 1999-2010.
;;;;  Copyright (c) Alan Watson 2012.
;;;;
;;;; This program is licensed under version 3 of the GNU LGPL. See
;;;; http://www.gnu.org/licenses/lgpl.html.
;;;;
;;;; This program reads lines of Scheme from its stdin and writes an
;;;; expanded, indented, and filled version to its stdout.

(define-library (scheme-indent main)

  (import (scheme base))
  (import (scheme process-context))
  (import (scheme file))
  (import (scheme read))
  (import (scheme write))

  (import (scheme-indent expand))
  (import (scheme-indent indent))
  (import (scheme-indent fill))

  (begin

    (define (fatal-error . rest)
      (parameterize ((current-output-port (current-error-port)))
        (display "scheme-indent: error: ")
        (for-each display rest)
        (newline)
        (exit 1)))

    (define-syntax with-fatal-error-handler
      (syntax-rules ()
        ((_ (message ...) body ...)
         (with-exception-handler
             (lambda (error-object)
               (fatal-error message ...))
           (lambda ()
             body ...)))))

    (define-syntax with-verbose-fatal-error-handler
      (syntax-rules ()
        ((_ (message ...) body ...)
         (with-exception-handler
             (lambda (error-object)
               (apply fatal-error
                      (string-append message ... (error-object-message error-object))
                      (error-object-irritants error-object)))
           (lambda ()
             body ...)))))

    ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

    ;; Customizations are read from the file named by
    ;; $SCHEME_INDENT_FILE, if this variable is set, or
    ;; $HOME/.scheme-indent. The customization file should either empty
    ;; or contain a list of customizations. Each customization is in
    ;; turn a list. Valid customizations have:
    ;;
    ;; (a) The car is the symbol tab-width and the cdar is an exact
    ;; positive integer. In this case, the cadr sets the value of the
    ;; tab width. The tab width defaults to 8.
    ;;
    ;; (b) The car is the symbol fill-width and the cdar is an exact
    ;; positive integer. In this case, the cadr sets the value of the
    ;; fill width. The fill width defaults to 72.
    ;;
    ;; (c) The car is an exact positive integer. In this case, the car
    ;; specifies the indentation of the symbols in the cdr.

    (define (customization-file-name)
      (get-environment-variable "SCHEME_INDENT_FILE"))

    (define (default-customization-file-name)
      (let ((home (get-environment-variable "HOME")))
        (and home (string-append home "/.scheme-indent"))))

    (define (open-customization-file)
      (let ((file-name (or (customization-file-name)
                           (default-customization-file-name))))
        (and (file-exists? file-name)
             (with-fatal-error-handler
                 ("unable to open the customization file \"" file-name "\".")
               (open-input-file file-name)))))

    (define (read-customization-list customization-port)
      (with-fatal-error-handler
          ("unable to read a valid customization list from the customization file.")
        (let ((object (read customization-port)))
          (cond
           ((eof-object? object) '())
           ((list? object) object)
           (else
            (fatal-error "the customization file does not contain a list."))))))

    (define *tab-width*  8)
    (define *fill-width* 72)

    (define (tab-width-customization customization)
      (unless (= 2 (length customization))
        (fatal-error "invalid customization \"" customization "\"."))
      (set! *tab-width* (cadr customization))
      (unless (and (integer? *tab-width*) (exact? *tab-width*) (positive? *tab-width*))
        (fatal-error "invalid tab width \"" *tab-width* "\".")))

    (define (fill-width-customization customization)
      (unless (= 2 (length customization))
        (fatal-error "invalid customization \"" customization "\"."))
      (set! *fill-width* (cadr customization))
      (unless (and (integer? *fill-width*) (exact? *fill-width*) (positive? *fill-width*))
        (fatal-error "invalid fill width \"" *fill-width* "\".")))

    (define (indent-customization customization)
      (let ((i (car customization))
            (names (cdr customization)))
        (when (not (and (integer? i)
                        (exact? i)
                        (not (negative? i))))
          (fatal-error "invalid customization: \"" customization "\"."))
        (for-each
         (lambda (name)
           (when (not (string? name))
             (fatal-error "invalid customization: \"" customization "\"."))
           (indent-set! i name))
         names)))

    (define (process-customization-list customization-list)
      (for-each
       (lambda (customization)
         (cond
          ((or (null? customization) (not (list? customization)))
           (error "invalid customization." customization))
          ((eq? (car customization) 'tab-width)
           (tab-width-customization customization))
          ((eq? (car customization) 'fill-width)
           (fill-width-customization customization))
          (else
           (indent-customization customization))))
       customization-list))

    (let* ((customization-port (open-customization-file))
           (customization-list (and customization-port
                                    (read-customization-list customization-port))))
      (process-customization-list customization-list))

    ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

    (define (port-filter p input-port)
      ;; The port-filter procedure filters input-port with the procedure
      ;; p. It calls p with the current input bound to input-port and
      ;; the current output bound to an output string port. When p
      ;; terminates, it returns an input string port whose contents are
      ;; taken from the output string port.
      (parameterize ((current-input-port  input-port)
                     (current-output-port (open-output-string)))
        (p)
        (open-input-string (get-output-string (current-output-port)))))

    (define (port-copy input-port output-port)
      ;; The port-copy procedure copies input-port to output-port.
      (parameterize ((current-input-port input-port))
        (let loop ()
          (let ((c (read-char)))
            (unless (eof-object? c)
              (write-char c output-port)
              (loop))))))

    ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

    (let* ((port (current-input-port))
           (port (with-verbose-fatal-error-handler ("while expanding: ")
                   (port-filter (lambda () (expand *tab-width*)) port)))
           (port (with-verbose-fatal-error-handler ("while indenting: ")
                   (port-filter indent port)))
           (port (with-verbose-fatal-error-handler ("while filling: ")
                   (port-filter (lambda () (fill *fill-width*)) port))))
      (with-verbose-fatal-error-handler ("while writing: ")
        (port-copy port (current-output-port))))

    (exit 0)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
